home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / DEMOTV01.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-24  |  6KB  |  224 lines
  1. program DEMOTV01;
  2. {------------------------------------------------------------------------------
  3.                               DBase File Display
  4.                              TurboVision Sample 1
  5.                                  Demo Program
  6.  
  7.        Copyright (c)  Richard F. Griffin
  8.  
  9.        24 February 1992
  10.  
  11.        102 Molded Stone Pl
  12.        Warner Robins, GA  31088
  13.  
  14.        -------------------------------------------------------------
  15.        This program demonstrates that the basic Griffin Solutions
  16.        routines will work in a TurboVision environment.  This demo
  17.        modifies one of the TP 6 TurboVision documentation programs
  18.        to use a dBase file.
  19.  
  20.        Memory is at a premium in the IDE using TurboVision.  For
  21.        this reason, Debug information is turned off in all of the
  22.        Griffin Solutions Units ($D-).  If you get heap overflow errors
  23.        or 'strange' things happen, if probably means there is not
  24.        enough memory to run in the IDE.  To regain memory, you can
  25.        compile to disk instead of memory.  Use the MemAvail value in
  26.        the Watch window to see how much memory is available.
  27.  
  28. -------------------------------------------------------------------------------}
  29.  
  30.  
  31. uses
  32.    GS_dBase,
  33.    GS_dBFld,
  34.    GS_FileH,
  35.    GS_GenF,
  36.    Objects, Drivers, Views, Menus, App;
  37.  
  38. const
  39.   MaxLines          = 100;
  40.   WinCount: Integer =   0;
  41.   cmFileOpen        = 100;
  42.   cmNewWin          = 101;
  43.  
  44. var
  45.   LineCount: Integer;
  46.   Lines: array[0..MaxLines - 1] of PString;
  47.    
  48. type
  49.   TMyApp = object(TApplication)
  50.     procedure HandleEvent(var Event: TEvent); virtual;
  51.     procedure InitMenuBar; virtual;
  52.     procedure InitStatusLine; virtual;
  53.     procedure NewWindow;
  54.   end;
  55.  
  56.   PInterior = ^TInterior;
  57.   TInterior = object(TScroller)
  58.     constructor Init(var Bounds: TRect; AHScrollBar,
  59.       AVScrollBar: PScrollBar);
  60.     procedure Draw; virtual;
  61.   end;
  62.  
  63.   PDemoWindow = ^TDemoWindow;
  64.   TDemoWindow = object(TWindow)
  65.     constructor Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  66.     procedure MakeInterior(Bounds: TRect);
  67.   end;
  68.  
  69. procedure ReadFile;
  70. var
  71.    dBFile  : GS_dBFld_Objt;
  72.    CkFile  : file;
  73.    s       : string;
  74. begin
  75.    if not GS_FileExists(CkFile,'DEMOTV1.DBF') then
  76.       MakeTestData('DEMOTV1', 20, false);
  77.    dBFile.Init('DEMOTV1');
  78.    dBFile.Open;
  79.    dBFile.GetRec(Top_Record);
  80.    LineCount := 0;
  81.    while not dBFile.File_EOF and (LineCount < MaxLines) do
  82.    begin
  83.       s := dBFile.FieldGet('LASTNAME') + dBFile.FieldGet('FIRSTNAME');
  84.       Lines[LineCount] := NewStr(S);
  85.       inc(LineCount);
  86.       dBFile.GetRec(Next_Record); {Get the next sequential record}
  87.    end;
  88.    dBFile.Close;                  {Close the dBase III file}
  89. end;
  90.  
  91. procedure DoneFile;
  92. var
  93.   I: Integer;
  94. begin
  95.   for I := 0 to LineCount - 1 do
  96.     if Lines[I] <> nil then DisposeStr(Lines[i]);
  97. end;
  98.  
  99. { TInterior }
  100. constructor TInterior.Init(var Bounds: TRect; AHScrollBar,
  101.   AVScrollBar: PScrollBar);
  102. begin
  103.   TScroller.Init(Bounds, AHScrollBar, AVScrollBar);
  104.   GrowMode := gfGrowHiX + gfGrowHiY;
  105.   Options := Options or ofFramed;
  106.   SetLimit(128, LineCount);
  107. end;
  108.  
  109. procedure TInterior.Draw;
  110. var
  111.   Color: Byte;
  112.   I, Y: Integer;
  113.   B: TDrawBuffer;
  114. begin
  115.   Color := GetColor(1);
  116.   for Y := 0 to Size.Y - 1 do
  117.   begin
  118.     MoveChar(B, ' ', Color, Size.X);
  119.     i := Delta.Y + Y;
  120.     if (I < LineCount) and (Lines[I] <> nil) then
  121.       MoveStr(B, Copy(Lines[I]^, Delta.X + 1, Size.X), Color);
  122.     WriteLine(0, Y, Size.X, 1, B);
  123.   end;
  124. end;
  125.  
  126. { TDemoWindow }
  127. constructor TDemoWindow.Init(Bounds: TRect; WinTitle: String;
  128.   WindowNo: Word);
  129. var
  130.   S: string[3];
  131. begin
  132.   Str(WindowNo, S);
  133.   TWindow.Init(Bounds, WinTitle + ' ' + S, wnNoNumber);
  134.   MakeInterior(Bounds);
  135. end;
  136.  
  137. procedure TDemoWindow.MakeInterior(Bounds: TRect);
  138. var
  139.   HScrollBar, VScrollBar: PScrollBar;
  140.   Interior: PInterior;
  141.   R: TRect;
  142. begin
  143.   VScrollBar := StandardScrollBar(sbVertical + sbHandleKeyboard);
  144.   HScrollBar := StandardScrollBar(sbHorizontal + sbHandleKeyboard);
  145.   GetExtent(Bounds);
  146.   Bounds.Grow(-1,-1);
  147.   Interior := New(PInterior, Init(Bounds, HScrollBar, VScrollBar));
  148.   Insert(Interior);
  149. end;
  150.  
  151. { TMyApp }
  152. procedure TMyApp.HandleEvent(var Event: TEvent);
  153. begin
  154.   TApplication.HandleEvent(Event);
  155.   if Event.What = evCommand then
  156.   begin
  157.     case Event.Command of
  158.       cmNewWin: NewWindow;
  159.     else
  160.       Exit;
  161.     end;
  162.     ClearEvent(Event);
  163.   end;
  164. end;
  165.  
  166. procedure TMyApp.InitMenuBar;
  167. var R: TRect;
  168. begin
  169.   GetExtent(R);
  170.   R.B.Y := R.A.Y + 1;
  171.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  172.     NewSubMenu('~F~ile', hcNoContext, NewMenu(
  173.       NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
  174.       NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext,
  175.       NewLine(
  176.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
  177.       nil))))),
  178.     NewSubMenu('~W~indow', hcNoContext, NewMenu(
  179.       NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
  180.       NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
  181.       nil))),
  182.     nil))
  183.   )));
  184. end;
  185.  
  186. procedure TMyApp.InitStatusLine;
  187. var R: TRect;
  188. begin
  189.   GetExtent(R);
  190.   R.A.Y := R.B.Y - 1;
  191.   StatusLine := New(PStatusLine, Init(R,
  192.     NewStatusDef(0, $FFFF,
  193.       NewStatusKey('', kbF10, cmMenu,
  194.       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
  195.       NewStatusKey('~F4~ New', kbF4, cmNewWin,
  196.       NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
  197.       nil)))),
  198.     nil)
  199.   ));
  200. end;
  201.  
  202. procedure TMyApp.NewWindow;
  203. var
  204.   Window: PDemoWindow;
  205.   R: TRect;
  206. begin
  207.   Inc(WinCount);
  208.   R.Assign(0, 0, 50, 15);
  209.   R.Move(Random(29), Random(8));
  210.   Window := New(PDemoWindow, Init(R, 'Demo Window', WinCount));
  211.   DeskTop^.Insert(Window);
  212. end;
  213.  
  214. var
  215.   MyApp: TMyApp;
  216.  
  217. begin
  218.   ReadFile;
  219.   MyApp.Init;
  220.   MyApp.Run;
  221.   MyApp.Done;
  222.   DoneFile;
  223. end.
  224.